Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/msword1a/wbrword.frm

Visual Basic Form | 1999-08-27 | 18.1 KB | 541 lines

VERSION 5.00
Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "SHDOCVW.DLL"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmWbrWord
   Caption         =   "Word"
   ClientHeight    =   3510
   ClientLeft      =   60
   ClientTop       =   630
   ClientWidth     =   5280
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   3510
   ScaleWidth      =   5280
   Tag             =   "Word"
   WindowState     =   2  'Maximized
   Begin MSComctlLib.StatusBar sta
      Align           =   2  'Align Bottom
      Height          =   315
      Left            =   0
      TabIndex        =   1
      Top             =   3195
      Width           =   5280
      _ExtentX        =   9313
      _ExtentY        =   556
      Style           =   1
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
         NumPanels       =   1
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
         EndProperty
      EndProperty
   End
   Begin SHDocVwCtl.WebBrowser wbr
      Height          =   2475
      Left            =   360
      TabIndex        =   0
      Top             =   360
      Width           =   4515
      ExtentX         =   7964
      ExtentY         =   4366
      ViewMode        =   1
      Offline         =   0
      Silent          =   0
      RegisterAsBrowser=   0
      RegisterAsDropTarget=   0
      AutoArrange     =   -1  'True
      NoClientEdge    =   0   'False
      AlignLeft       =   0   'False
      ViewID          =   "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
      Location        =   ""
   End
   Begin VB.Menu mnuFileMenu
      Caption         =   "&File"
      Begin VB.Menu mnuFile
         Caption         =   "&Open..."
         Index           =   0
      End
      Begin VB.Menu mnuFile
         Caption         =   "&Close"
         Index           =   1
      End
      Begin VB.Menu mnuFile
         Caption         =   "-"
         Index           =   2
      End
      Begin VB.Menu mnuFile
         Caption         =   "&Save"
         Index           =   3
      End
      Begin VB.Menu mnuFile
         Caption         =   "Save &As..."
         Index           =   4
      End
      Begin VB.Menu mnuFile
         Caption         =   "Save as &HTML..."
         Index           =   5
      End
      Begin VB.Menu mnuFile
         Caption         =   "-"
         Index           =   6
      End
      Begin VB.Menu mnuFile
         Caption         =   "Page Set&up..."
         Index           =   7
      End
      Begin VB.Menu mnuFile
         Caption         =   "&Print..."
         Index           =   8
         Shortcut        =   ^P
      End
      Begin VB.Menu mnuFile
         Caption         =   "-"
         Index           =   9
      End
      Begin VB.Menu mnuFile
         Caption         =   "Properties"
         Index           =   10
         Begin VB.Menu mnuFileProps
            Caption         =   "Summary Info"
            Index           =   0
         End
         Begin VB.Menu mnuFileProps
            Caption         =   "Word Count"
            Index           =   1
         End
      End
      Begin VB.Menu mnuFile
         Caption         =   "-"
         Index           =   11
      End
      Begin VB.Menu mnuFile
         Caption         =   "Close &Window"
         Index           =   12
      End
   End
   Begin VB.Menu mnuViewMenu
      Caption         =   "&View"
      Begin VB.Menu mnuView
         Caption         =   "Normal View"
         Index           =   0
      End
      Begin VB.Menu mnuView
         Caption         =   "Page Layout"
         Index           =   1
      End
      Begin VB.Menu mnuView
         Caption         =   "-"
         Index           =   2
      End
      Begin VB.Menu mnuView
         Caption         =   "Horizontal Scroll"
         Index           =   3
      End
      Begin VB.Menu mnuView
         Caption         =   "Ruler"
         Index           =   4
      End
      Begin VB.Menu mnuView
         Caption         =   "Toolbars"
         Index           =   5
         Begin VB.Menu mnuViewToolbar
            Caption         =   "Standard"
            Index           =   0
         End
         Begin VB.Menu mnuViewToolbar
            Caption         =   "Formatting"
            Index           =   1
         End
         Begin VB.Menu mnuViewToolbar
            Caption         =   "Drawing"
            Index           =   2
         End
         Begin VB.Menu mnuViewToolbar
            Caption         =   "Reviewing"
            Index           =   3
         End
      End
   End
   Begin VB.Menu mnuToolsMenu
      Caption         =   "&Tools"
      Begin VB.Menu mnuTools
         Caption         =   "&Spelling"
         Index           =   0
      End
      Begin VB.Menu mnuTools
         Caption         =   "&Thesaurus..."
         Index           =   1
      End
      Begin VB.Menu mnuTools
         Caption         =   "&Options"
         Index           =   2
         Begin VB.Menu mnuOpt
            Caption         =   "Show All"
            Index           =   0
         End
         Begin VB.Menu mnuOpt
            Caption         =   "Status Bar"
            Checked         =   -1  'True
            Index           =   1
         End
      End
   End
Attribute VB_Name = "frmWbrWord"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' WbrWord.frm v1.00 (Vb6) Apr 1999  contact [e-mail]
' Uses WebBrowser Control as container for MS Word Document.
' Project/References must include:-
'   Microsoft Word 8.0 Object Library (MSWord8.olb)
'   Microsoft Office 8.0 Object Library (MSO97.dll)
'   Microsoft Dialog Automation Objects (DlgObjs.dll)
' Note settings for the following properties (change for stand-alone form):-
'   MDIChild = True
'   ControlBox = False
'NB: WinWord is started when a Word document is loaded into the
'    WebBrowser Control and remains active until that Control is destroyed.
'    This can be confirmed using Ctrl-Alt-Del to view the task list.
'=================================================================================
' Module-level Variables
Private MARGINx2 As Long
Private mTopUsedArea As Long    ' varies with ToolBar/Captions visibility
Private mBotUsedArea As Long    ' varies with StatusBar visibility
Private mVertUsedArea As Long   ' = mTopUsedArea + mBotUsedArea
Private mDoc As Word.Document   ' Word Document contained by WebBrowser Control
Private mDocURL As String       ' URL of Word Document contained by WebBrowser Control
' Module-level Constants
Private Const MARGIN = 0        ' set as required (Twips)
Private Const TITLE_HEAD = "<HEAD>" _
            & "<style type='text/css'>" _
            & "BODY" _
            & "{color:white;" _
            & "background-color:#689CD0;" _
            & "font:48pt 'Comic Sans MS';" _
            & "text-align:center}" _
            & "</style>" _
            & "</HEAD>"
Private Const TITLE_BODY = "<BODY SCROLL=NO>" _
            & "MS Word<BR>Document<BR>Container" _
            & "</BODY>"
Private Const TITLE_PAGE = "about:" & TITLE_HEAD & TITLE_BODY
' Browser navigation constants
Private Const navNoHistory = 2
Private Const navNoReadFromCache = 4
Private Const navNoWriteToCache = 8
Private Const mNavFlags = navNoHistory Or navNoReadFromCache Or navNoWriteToCache
' File Menu constants
Private Const FILE_OPEN = 0
Private Const FILE_CLOSE = 1
Private Const FILE_SAVE = 3
Private Const FILE_SAVEAS = 4
Private Const FILE_SAVEASHTML = 5
Private Const FILE_PAGESETUP = 7
Private Const FILE_PRINT = 8
Private Const FILE_PROPS = 10
Private Const FILE_CLOSEWIN = 12
' Properties Menu constants
Private Const PROP_SUMMARY = 0
Private Const PROP_WORDCOUNT = 1
' View Menu constants
Private Const VIEW_NORMAL = 0
Private Const VIEW_PAGE = 1
Private Const VIEW_HSCROLL = 3
Private Const VIEW_RULER = 4
' Tool Menu constants
Private Const TOOLS_SPELL = 0
Private Const TOOLS_THESAURUS = 1
Private Const TOOLS_OPTIONS = 2
' Option Menu constants
Private Const OPT_SHOWALL = 0
Private Const OPT_STATUSBAR = 1
Private Sub Form_Load()
    MARGINx2 = MARGIN * 2
    mTopUsedArea = MARGIN   ' + VB toolbar height, if present
    mBotUsedArea = sta.Height
    mVertUsedArea = mTopUsedArea + mBotUsedArea
    wbr.Navigate TITLE_PAGE, mNavFlags  ' Doco says Navigate2 not applicable to VB
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If Not (mDoc Is Nothing) Then
        If Not mDoc.Saved Then
            Cancel = True
            MsgBox "This Document has been changed." _
                    & vbNewLine & vbNewLine _
                    & "Please Close or Save from the File Menu.", _
                    vbExclamation, App.FileDescription
        End If
    End If
End Sub
Private Sub Form_Resize()
    On Error Resume Next
    wbr.Move MARGIN, mTopUsedArea, Me.ScaleWidth - MARGINx2, Me.ScaleHeight - mVertUsedArea
End Sub
Private Sub mnuFileMenu_Click()
    Dim IsWordDoc As Boolean
    Dim IsSaved As Boolean
    IsWordDoc = Not (mDoc Is Nothing)
    If IsWordDoc Then
        IsSaved = mDoc.Saved
    End If
    mnuFile(FILE_CLOSE) = IsWordDoc
    mnuFile(FILE_SAVE) = IsWordDoc And Not IsSaved
    mnuFile(FILE_SAVEAS) = IsWordDoc
    mnuFile(FILE_SAVEASHTML) = IsWordDoc
    mnuFile(FILE_PAGESETUP) = IsWordDoc
    mnuFile(FILE_PRINT) = IsWordDoc
    mnuFile(FILE_PROPS) = IsWordDoc
    mnuFile(FILE_CLOSEWIN) = IsSaved Or Not IsWordDoc
End Sub
Private Sub mnuFile_Click(Index As Integer)
    On Error Resume Next
    Dim FileName As String
    Select Case Index
        Case FILE_OPEN
            FileName = FileDlgs.GetOpenFileName( _
                            App.Path, _
                            "Word Documents (*.doc):*.doc", _
                            "Rich Text Format (*.rtf):*.rtf")
            If Len(FileName) Then
                sta.SimpleText = "Opening " & FileName & " ..."
                wbr.Navigate FileName, mNavFlags
            End If

        Case FILE_CLOSE
            wbr.Navigate TITLE_PAGE, mNavFlags  ' removes Word document but
                                                ' DOES NOT close Word instance
        Case FILE_SAVE
            wbr.ExecWB _
                cmdID:=OLECMDID_SAVE, _
                cmdexecopt:=OLECMDEXECOPT_PROMPTUSER

        Case FILE_SAVEAS
            wbr.ExecWB _
                cmdID:=OLECMDID_SAVEAS, _
                cmdexecopt:=OLECMDEXECOPT_PROMPTUSER

        Case FILE_SAVEASHTML
            FileSaveAsHTML

        Case FILE_PAGESETUP
            wbr.ExecWB _
                cmdID:=OLECMDID_PAGESETUP, _
                cmdexecopt:=OLECMDEXECOPT_PROMPTUSER

        Case FILE_PRINT
            wbr.ExecWB _
                cmdID:=OLECMDID_PRINT, _
                cmdexecopt:=OLECMDEXECOPT_PROMPTUSER

        Case FILE_CLOSEWIN
            Unload Me

    End Select
End Sub
Private Sub mnuFileProps_Click(Index As Integer)
' See VbaWrd8.HLP for distinction between "Show" and "Display" methods
    On Error Resume Next
    Select Case Index
        Case PROP_SUMMARY  ' Word Document Summary Info
            mDoc.Application.Dialogs(wdDialogFileSummaryInfo).Show

        Case PROP_WORDCOUNT  ' Word Document Word Count (display only)
            mDoc.Application.Dialogs(wdDialogToolsWordCount).Display

    End Select

End Sub
Private Sub mnuViewMenu_Click()
    On Error Resume Next
    Dim mnu As Menu
    With mDoc
        With .ActiveWindow
            mnuView(VIEW_NORMAL).Checked = (.View.Type = wdNormalView)
            mnuView(VIEW_PAGE).Checked = (.View.Type = wdPageView)
            mnuView(VIEW_HSCROLL).Checked = .DisplayHorizontalScrollBar
            mnuView(VIEW_RULER).Checked = .DisplayRulers
        End With

        For Each mnu In mnuViewToolbar  ' Assumes Menu captions match Toolbar names
            mnu.Checked = .CommandBars(mnu.Caption).Visible
        Next

    End With
End Sub
Private Sub mnuView_Click(Index As Integer)
    On Error Resume Next
    With mDoc.ActiveWindow
        Select Case Index

            Case VIEW_NORMAL
                .View.Type = wdNormalView

            Case VIEW_PAGE
                .View.Type = wdPageView

            Case VIEW_HSCROLL
                .DisplayHorizontalScrollBar = Not .DisplayHorizontalScrollBar

            Case VIEW_RULER
                .DisplayRulers = Not .DisplayRulers

        End Select
    End With
End Sub
Private Sub mnuViewToolbar_Click(Index As Integer)
    On Error Resume Next
    Dim msoBarPos As Office.MsoBarPosition
    Dim strToolbarName As String
    strToolbarName = mnuViewToolbar(Index).Caption
    With mDoc.CommandBars(strToolbarName)
        .Enabled = True ' ToolBar must be Enabled before it can be made Visible
        .Visible = Not .Visible
        mnuViewToolbar(Index).Checked = .Visible

        If .Visible Then

            Select Case strToolbarName

                Case "Drawing"
                    msoBarPos = msoBarBottom

                Case "Reviewing"
                    msoBarPos = msoBarRight

                Case Else
                    msoBarPos = msoBarTop
            End Select

            .Position = msoBarPos

        End If

    End With
End Sub
Private Sub mnuToolsMenu_Click()
    On Error Resume Next
    With mDoc
        mnuTools(TOOLS_SPELL) = Not .SpellingChecked

        With .Application.Selection ' restrict to one word only
            mnuTools(TOOLS_THESAURUS) = (.Type = wdSelectionNormal) _
                                    And (.Words.Count = 1)
        End With

    End With
End Sub
Private Sub mnuTools_Click(Index As Integer)
    On Error Resume Next
    Select Case Index
        Case TOOLS_SPELL
            mDoc.CheckSpelling

        Case TOOLS_THESAURUS
            mDoc.Application.Selection.Range.CheckSynonyms

        Case TOOLS_OPTIONS
            mnuOpt(OPT_SHOWALL).Checked = mDoc.ActiveWindow.View.ShowAll
            mnuOpt(OPT_STATUSBAR).Checked = sta.Visible

    End Select
End Sub
Private Sub mnuOpt_Click(Index As Integer)
    On Error Resume Next
    Dim blnChecked As Boolean
    With mnuOpt(Index)
        .Checked = Not .Checked
        blnChecked = .Checked
    End With
    Select Case Index
        Case OPT_SHOWALL
            mDoc.ActiveWindow.View.ShowAll = blnChecked

        Case OPT_STATUSBAR
            sta.Visible = blnChecked
            SetBotUsedArea

    End Select
End Sub
Private Sub wbr_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    On Error GoTo DocumentComplete_Error
    If pDisp Is wbr.Object Then
        mnuViewMenu = TypeOf wbr.Document Is Word.Document
        mnuToolsMenu = mnuViewMenu

        If mnuViewMenu Then
            Set mDoc = wbr.Document
            mDocURL = URL
            Me.Caption = mDocURL
            sta.SimpleText = "Done"
        Else
            Set mDoc = Nothing
            mDocURL = vbNullString
            Me.Caption = Me.Tag
        End If

    End If
DocumentComplete_Exit:
    Exit Sub
DocumentComplete_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, _
                Me.Name & ".DocumentComplete"
    Resume DocumentComplete_Exit
End Sub
Private Sub wbr_StatusTextChange(ByVal Text As String)
    sta.SimpleText = Text
End Sub
Private Sub FileSaveAsHTML()
' This can also be done with the "SaveAs" option.
' Note that ConvHTML.SaveDocAsHTML could be used to convert a
' document to HTML withtout user intervention if parameters
' are provided by some other means.
    On Error GoTo FileSaveAsHTML_Error
    Dim FileName As String
    Dim lngPos As Long
    Dim strResult As String
    Dim strMsg As String
    Dim lngStyle As VbMsgBoxStyle
    lngPos = InStrRev(mDocURL, "\", , vbTextCompare)
    If lngPos Then
        FileName = Mid$(mDocURL, lngPos + 1)
        FileName = Split(FileName, ".")(0) & ".html"
        FileName = LCase$(FileName)
    End If
    strResult = FileDlgs.GetSaveAsFileName( _
                    FileName, _
                    App.Path, _
                    "HTML Document (*.htm;*.html):*.htm;*.html")

    If Len(strResult) Then
        FileName = ConvHTML.SaveDocAsHTML( _
                    Doc:=mDoc, _
                    NewFileName:=strResult)
        If Len(FileName) Then
            strMsg = mDocURL & vbNewLine & vbNewLine _
                    & vbTab & "saved in HTML format as" & vbNewLine & vbNewLine _
                    & FileName
            lngStyle = vbInformation
        Else
            strMsg = "ERROR: Save operation failed"
            lngStyle = vbExclamation
        End If
        MsgBox strMsg, lngStyle, "Save As HTML"
    End If
FileSaveAsHTML_Exit:
    Exit Sub
FileSaveAsHTML_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, _
                Me.Name & ".FileSaveAsHTML"
    Resume FileSaveAsHTML_Exit
End Sub
Private Sub SetBotUsedArea()
    With sta
        .Refresh
        mBotUsedArea = IIf(.Visible, .Height + MARGIN, MARGIN)
    End With
    mVertUsedArea = mTopUsedArea + mBotUsedArea
    Form_Resize
End Sub